COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(SETQ BASE 10. IBASE 10.)
C00012 ENDMK
C⊗;
(SETQ BASE 10. IBASE 10.)

(DEFMACRO E:DO (STRING)
  `(EM:ECOMMANDS (EXPLODEC ,STRING)) )

(DEFMACRO E:VAR (VARNAME)
  `(CDAR (EM:READONLY-VARS '(,VARNAME))) )

(DEFMACRO CONSP (EXPR)
   `(EQ (TYPEP ,EXPR) 'LIST) )

(DEFUN NSUBLIS (A-LIST S-EXPR &aux SUBSTPAIR)
  (COND ((CONSP S-EXPR)
	   (COND ((CONSP (CAR S-EXPR)) (NSUBLIS A-LIST (CAR S-EXPR)))
		 ((SETQ SUBSTPAIR (ASSQ (CAR S-EXPR) A-LIST))
		    (RPLACA S-EXPR (CDR SUBSTPAIR)) ) )
	   (COND ((CONSP (CDR S-EXPR)) (NSUBLIS A-LIST (CDR S-EXPR)))
		 ((SETQ SUBSTPAIR (ASSQ (CDR S-EXPR) A-LIST))
		    (RPLACD S-EXPR (CDR SUBSTPAIR)) ) )
	   S-EXPR )
	((COND ((SETQ SUBSTPAIR (ASSQ S-EXPR A-LIST)) (CDR SUBSTPAIR))
	       (S-EXPR) )) ) )

(DEFMACRO *DEFUN ((F-TYPE . F-NAME) ARGLIST . BODY)
  `(PROGN
      (PUTPROP (OR (GET ',F-NAME 'FUNCTIONS) 
		   (PUTPROP ',F-NAME (NCONS '|*DEFUN-plist|) 'FUNCTIONS))
	       ,(COND ((EQ (CAR BODY) '*SYN) `',(CADR BODY))
		      (T `'(LAMBDA ,ARGLIST ,@BODY)) )
	       ',F-TYPE )
      (LET ((OLDMACRO (GET ',F-TYPE 'MACRO))
	    (NEWMACRO '(LAMBDA (FORM)
			`(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) )) )
	   (COND ((AND OLDMACRO 
		       (NOT (EQUAL OLDMACRO NEWMACRO)) )
		  (TERPRI) (PRINC '|Macro |) (PRIN1 ',F-TYPE)
		  (PRINC '| already defined differently!|)
		  (BREAK *DEFUN) )) )
      (DEFUN ,F-TYPE MACRO (FORM)
	 `(GET (GET ',(CDR FORM) 'FUNCTIONS) ',',F-TYPE) ) ) )

(*DEFUN (ISA . COREROLE) (ROLEMARK LT-FORM)
   (MEMQ ROLEMARK (GET (PFC-CONCEPT LT-FORM) 'COREROLES)) )

(*DEFUN (THE-FOR:ROLELINK . ROLEPHRASE) (ROLELINK LT-FORM)
   (CDR (ASSQ (ROLEMARK ROLELINK) (GET (PFC-CONCEPT LT-FORM) 'ROLEXICON))) )

(*DEFUN (THE-OF:LT-QUANT . QSORT) (LT-QUANT)
   (LET* ((QSORTEXPR (LT-QSORT-EXPR LT-QUANT))
	  (ATOMICQSORTEXPR
	    (CASEQ (LT-TYPE QSORTEXPR)
	       (ATOMICPROPO QSORTEXPR)
	       (CONJ-PROPO (ARGUMENT (CAR (ROLELINKS QSORTEXPR)))) ) ) )
	 (COND ((EQ (PFC-CONCEPT ATOMICQSORTEXPR) 'CONCEPT) 
		  (NORMALIZE-TERMSORTEXPR
		   (CONS '↑
			 (COND ((ARGUMENT (ASSQ 'OBJECT-CATEGORY*
						(ROLELINKS ATOMICQSORTEXPR) )))
			       (T (TERMSORT
				   (ARGUMENT
				    (ASSQ 'OBJECT
					  (ROLELINKS ATOMICQSORTEXPR) ) ) )) ) ) ) )
	       (T (PFC-CONCEPT ATOMICQSORTEXPR)) )) )

(*DEFUN (THE-OF:LT-QUANT . DETERMINER) (LT-QUANT)
    *SYN CAR )
;   *SYN LT-Q-DETERMINER )  This usage causes an "; IMPROPER USE OF MACRO - EVAL"
; error message; what LISP doesn't like here is simply the fact that 
; LT-Q-DETERMINER is a macro.

(*DEFUN (THE-OF:LT-λ-PREFIX . PATHKEYLISTS) (λ-PREFIX)
    *SYN CDR )

(*DEFUN (THE-OF:LT-QUANT . QSORTEXPR) (LT-QUANTIFIER)
    (CXR 2 LT-QUANTIFIER) )

(*DEFUN (THE-OF:LT-QUANT . SCOPE) (LT-QUANTIFIER)
    (CXR 3 LT-QUANTIFIER) )

(*DEFUN (THE-OF:LINQUANT . DETERMINER) (LINQUANT)
    (CAR LINQUANT) )

(*DEFUN (ISA-OF:LT . λ-EXPR) (LT-FORM)
   (AND (CONSP LT-FORM) (CONSP (CAR LT-FORM)) (MEMQ (CAAR LT-FORM) '(λ LAMBDA))) )

; λ-pair: (<λ-mark> . <termsort-indicator>)
; λ-mark: λ
; termsort-indicator: either <termsort-atom> or (<↑-marker> . <termsort-atom>)
; ↑-marker: either ↑ or ↑n , n being a digit such that 2≤n≤9.
(*DEFUN (ISA . λ-PAIR) (SUBSTFORM)
  (AND (CONSP SUBSTFORM)
       (EQ 'λ (CAR SUBSTFORM))
       (OR (SYMBOLP (CDR SUBSTFORM))
	   (AND (SYMBOLP (CADR SUBSTFORM))
		(EQ '↑ (GETCHAR (CADR SUBSTFORM) 1)) ) ) ) )

(*DEFUN (ISA-OF:LT . SORT) (PFC-CONCEPT)
  (LET  ((CONCEPT-CATEGORY (GET PFC-CONCEPT 'CATEGORY)))
	(OR (EQ 'SORT CONCEPT-CATEGORY)
	    (SUPERSORT* 'SORT CONCEPT-CATEGORY) ) ) )

(*DEFUN (ISA . SORT-ATTR-CATEGORY) (CATEGORY)
   (OR (MEMQ CATEGORY '(SORT ATTRIBUTE))
       (SUPERSORT* 'SORT CATEGORY)
       (SUPERSORT* 'ATTRIBUTE CATEGORY) ) )

(*DEFUN (ISA-OF:LT . PFC-FORMULA) (LT-FORM)
  (COND ((NOT (CONSP LT-FORM)) NIL)
	(T (LET ((CARFORM-CATEGORY (GET (CAR LT-FORM) 'CATEGORY)))
		(AND CARFORM-CATEGORY
		     (OR (MEMQ CARFORM-CATEGORY '(FUNCTION CONNECTIVE))
			 (#.(ISA . SORT-ATTR-CATEGORY) CARFORM-CATEGORY) ) ) )) ) )

(*DEFUN (ISA . PATT-VARIABLE) (FORM)
   (OR (AND (SYMBOLP FORM)
	    (MEMQ (GETCHAR FORM 1) '(? *)) )
       (AND (CONSP FORM)
	    (MEMQ (CAR FORM) '($R $IR $CHOOSE)) ) ) )

(*DEFUN (ISA . *-PATT-VARIABLE) (FORM)
   (OR (AND (SYMBOLP FORM)
	    (EQ (GETCHAR FORM 1) '*) )
       (AND (CONSP FORM)
	    (MEMQ (CAR FORM) '($R $IR))
	    (EQ (GETCHAR (CADR FORM) 1) '*) ) ) )

(*DEFUN (ISA . ROLELINK) (LT-FORM)
   (AND (CONSP LT-FORM) (EQ (GET (CAR LT-FORM) 'CATEGORY) 'ROLEMARK)) )

(*DEFUN (ISA-OF:LIN . QUANTIFIER) (LINFORM)
   (EQ (GET (CAR LINFORM) 'CATEGORY) 'DETERMINER) )

(*DEFUN (ISA-OF:LT . QUANTIFIER) (LT-FORM)
   (EQ (GET (#.(THE-OF:LT-QUANT . DETERMINER) LT-FORM) 'CATEGORY) 'DETERMINER) )

(*DEFUN (ISA . LEAF-NODE) (NODE)
   (OR (ATOM (LEAF-UNIT NODE))
       (EQ '*CC-PLIST* (CAR (LEAF-PLIST NODE))) ) )

(*DEFUN (ISA . CC-OP) (ATOM)
   (LET ((BASE-OP (GET-BASE-OP ATOM)))
	(MEMQ BASE-OP '(INST ADVB QUANT CNCT RLMRG VECT)) ) )

(*DEFUN (ISA . BREAK-BEFORE-POINT) (PRINTATOM)
   (AND (SYMBOLP PRINTATOM)
	(EQ '↑ (GETCHAR PRINTATOM 1))
	(OR (EQ '/[ (GETCHAR PRINTATOM 2))
	    (EQ '/[ (GETCHAR PRINTATOM 3)) ) ) )
;	(EQ '/[ (CAR (LAST (EXPLODE PRINATOM)))) ) ) ;; too much consing

(*DEFUN (ISA . BREAK-POINT) (PRINTATOM)
   (MEMQ PRINTATOM BREAK-POINTS) )